perm filename KSIG.F4[P11,LCS] blob
sn#570602 filedate 1981-03-06 generic text, type T, neo UTF8
SUBROUTINE KSIG
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(17),T,Z,H/STF/RSTFAC(-3/4),RSTJ2
C******************;;;; Z WIPED OUT IN NOTWRT!!! BE CAREFUL WITH S!!!
EQUIVALENCE (R4,RJQ(2)),(J4,JQ(2)),(J5,JQ(3)),(J6,JQ(4))
1,(R6,RJQ(4)),(R3,RJQ(1))
JA=9
C USES THIS KEY NUM IN NOTWRT
IZ=IABS(J5)
C NUMBER OF CALLS ON NOTWRT
C THE CLEF NUM. IT GETS WIPED OUT IN NOTWRT.
JW=1
R6=0
IF(J5.GT.0)JW=2
C THE CODE FOR FLAT OR SHARP
IF(IZ.LT.100)GO TO 5333
JW=3
IZ=IZ-100
C WILL MAKE NATURALS IF 100 IS ADDED OR SUBTRACTED.
5333 CLEF=J6
CLEF #S ARE 0,1,2,3 (TREB.,BA.,ALT.,TEN.)
C CLEF NOW SET IN MAIN PROG. IF NO CLEF GIVEN, TREBLE IS USED.
IF(J6.LT.100)GO TO 53
R6=.8
CLEF=CLEF-100.
53 T=10.
C MINIS
IF(CLEF.GT.1.)T=11.
S=3.-CLEF
IF(S.EQ.0)S=-1.
IF(J5.LT.0)GO TO 253
W=-3.
YY=4.
Z=11.
C SHARPS
GO TO 353
253 W=-4
YY=3.
Z=7.
C FLATS
353 N=-1
Z=Z+R4
RX=R3
RA=0
C RA IS AMOUNT TO BE ADDED TO ORIGINAL POS.
WW=RSTJ2*13.
IF(R6.NE.0)WW=WW*R6
RD6=R6
DO 553 KA=1,IZ
J5=JW
R3=RX+RA
RA=RA+WW
C MOVES OVER FOR NEXT ACCI.
R6=RD6
C SIZE - R6 GETS WIPED OUT IN NOTWRT
RD=Z
R4=Z
IF(CLEF.NE.0)GO TO 7
IF(R4.GT.12.)R4=R4-7.
GO TO 9
7 R4=R4-S
IF(R4.GT.T)R4=R4-7.
C ABOVE ARRANGES VERT. POS OF ACCIS.
9 J4=R4
C FOR VERT. POS. IN 'DRWNT' (WHEN PLOTTING.)
CALL CENTX
CALL NOTWRT
Z=RD+W
IF(N.LT.0)Z=RD+YY
C N WAS -1 1ST TIME.
553 N=-N
END